home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / KERNEL2.SEQ < prev    next >
Text File  |  1988-09-09  |  31KB  |  877 lines
  1. \ KERNEL2.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL2.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. USER DEFINITIONS
  10. VARIABLE  TOS         ( TOP OF STACK )
  11. VARIABLE  ENTRY       ( ENTRY POINT, CONTAINS MACHINE CODE )
  12. VARIABLE  LINK        ( LINK TO NEXT TASK )
  13. VARIABLE  ES0         ( INITIAL ES: SEGMENT )
  14. VARIABLE  SP0         ( INITIAL PARAMETER STACK )
  15. VARIABLE  RP0         ( INITIAL RETURN STACK )
  16. VARIABLE  DP          ( DICTIONARY POINTER )
  17. VARIABLE  OFFSET      ( RELATIVE TO ABSOLUTE DISK BLOCK 0 )
  18. VARIABLE  BASE        ( FOR NUMERIC INPUT AND OUTPUT )
  19. VARIABLE  HLD         ( POINTS TO LAST CHARACTER HELD IN PAD )
  20. VARIABLE  PRINTING
  21.    DEFER  EMIT
  22.    DEFER  KEY?
  23.    DEFER  KEY
  24.    DEFER  TYPE
  25.    DEFER  EXTYPE
  26.  
  27. META DEFINITIONS
  28. VARIABLE  PRIOR     ( USED FOR DICTIONARY SEARCHES )
  29. VARIABLE  STATE     ( COMPILATION OR INTERPRETATION )
  30. VARIABLE  WARNING   ( GIVE USER DUPLICATE WARNINGS IF ON )
  31. VARIABLE  DPL       ( NUMERIC INPUT PUNCTUATION )
  32. VARIABLE  R#        ( EDITING CURSOR POSITION )
  33. VARIABLE  LAST      ( POINTS TO NFA OF LATEST DEFINITION )
  34. VARIABLE  CSP       ( HOLDS STACK POINTER FOR ERROR CHECKING )
  35. VARIABLE  CURRENT   ( VOCABULARY WHICH GETS DEFINITIONS )
  36. 8 CONSTANT #VOCS    ( THE NUMBER OF VOCABULARIES TO SEARCH )
  37. VARIABLE  CONTEXT   ( VOCABULARY SEARCHED FIRST )
  38.    HERE THERE #VOCS 2* DUP ALLOT ERASE
  39.  
  40. VARIABLE  'TIB      ( ADDRESS OF TERMINAL INPUT BUFFER )
  41. VARIABLE  WIDTH     ( WIDTH OF NAME FIELD )
  42. VARIABLE  VOC-LINK  ( POINTS TO NEWEST VOCABULARY )
  43. VARIABLE  >IN       ( OFFSET INTO INPUT STREAM )
  44. VARIABLE  SPAN      ( NUMBER OF CHARACTERS EXPECTED )
  45. VARIABLE  #TIB      ( NUMBER OF CHARACTERS TO INTERPRET )
  46. VARIABLE  END?      ( TRUE IF INPUT STREAM EXHAUSTED )
  47. VARIABLE  #OUT      ( NUMBER OF CHARACTERS EMITTED )
  48. VARIABLE  #LINE     ( THE NUMBER OF LINES SENT SO FAR )
  49.  
  50. VARIABLE XDP
  51. VARIABLE XDPSEG
  52. VARIABLE YDP            \ HEADER SEG POINTER
  53. VARIABLE YSTART         \ HEAD  START OFFSET
  54. VARIABLE DPSTART        \ LIST  START OFFSET
  55. VARIABLE XSEGLEN
  56. VARIABLE XMOVED         \ FLAG TO TELL IF LIST HAS BEEN MOVED
  57. VARIABLE SSEG           \ SEARCH & SCAN SEGMENT
  58.  
  59. 0  VALUE SEQHANDLE      \ THE SEQUENTIAL HANDL POINTER
  60. VARIABLE LOADLINE       \ Offset to line we loaded from
  61. VARIABLE ERRORLINE      \ Last loaded line #
  62.  
  63. 32 CONSTANT BL
  64.  8 CONSTANT BS
  65.  7 CONSTANT BELL
  66.  
  67. VARIABLE CAPS
  68.  
  69. CODE FILL       (  start-addr count char -- )
  70.                 CLD             MOV BX, DS
  71.                 POP AX          POP CX          POP DI
  72.                 PUSH ES         MOV ES, BX
  73.                 REPNZ           STOSB           POP ES
  74.                 NEXT            END-CODE
  75.  
  76. CODE LFILL      (  seg start-addr count char -- )
  77.                 CLD             POP AX          POP CX
  78.                 POP DI          POP BX
  79.                 PUSH ES         MOV ES, BX
  80.                 REPNZ           STOSB           POP ES
  81.                 NEXT            END-CODE
  82.  
  83. : ERASE         ( addr len -- ) 0 FILL   ;
  84. : BLANK         ( addr len -- ) BL FILL   ;
  85.  
  86. CODE COUNT      ( addr -- addr+1 len )
  87.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  88.                 INC BX          PUSH BX
  89.                 1PUSH           END-CODE
  90.  
  91. CODE LENGTH     ( addr -- addr+2 len )    \ REALLY WORD COUNT
  92.                 POP BX          MOV AX, 0 [BX]
  93.                 ADD BX, # 2
  94.                 PUSH BX         1PUSH           END-CODE
  95.  
  96. : MOVE          ( from to len -- )
  97.                 -ROT   2DUP U< IF   ROT CMOVE>   ELSE   ROT CMOVE   THEN ;
  98.  
  99. DECIMAL
  100.  
  101. CREATE ATBL     \ Uppercase translation table
  102.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  103.  8  C,  32  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  104. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  105. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  106. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  107. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  108. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  109. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  110. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  111. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  112. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  113. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  114. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  115. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  116. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  117. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  118. \ Characters above 127 are translated to below 127
  119.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  120.  8  C,   9  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  121. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  122. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  123. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  124. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  125. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  126. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  127. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  128. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  129. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  130. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  131. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  132. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  133. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  134. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  135.  
  136. CODE UPC        ( char -- char' )
  137.                 POP AX
  138.                 MOV BX, # ATBL
  139.                 XLAT
  140.                 1PUSH
  141.                 END-CODE
  142.  
  143. CODE UPPER      ( addr len -- )         \ convert string to upper case
  144.                         POP CX                  \ get length
  145.                         POP DI                  \ and starting address
  146. LABEL >UPPER+2          PUSH SI                 \ save IP
  147.                         MOV DX, ES              \ and LIST POINTER
  148.                         MOV BX, DS
  149.                         MOV ES, BX              \ set ES to DS
  150.                         MOV SI, DI              \ set SI to DI
  151.                         MOV BX, # ATBL          \ loadup BX with table
  152.                         CLD                     \ clear direction flag
  153.               CX<>0 IF
  154.                         HERE                    \ get a char and traslate it
  155.                                 LODSB   XLAT
  156.                                 STOSB
  157.                         LOOPNZ                  \ until all chars are done
  158.                     THEN
  159.                         MOV ES, DX              \ restore ES=LIST
  160.                         POP SI                  \     and SI=IP
  161.                         NEXT    END-CODE
  162.  
  163. CODE ?UPPERCASE ( A1 --- A1 )           \ conditionally convert to upper case
  164.                 MOV CX, CAPS                    \ test CAPS variable
  165.   CX<>0 IF                                      \ leave if CAPS is not on
  166.                 POP DI          PUSH DI         \ get a copy of address a1
  167.                 SUB CX, CX      MOV CL, 0 [DI]
  168.                 INC DI                          \ Addr and Cnt in DI & CX
  169.                 JMP >UPPER+2                    \ go translate to upper case
  170.         THEN
  171.                 NEXT
  172.                 END-CODE
  173.  
  174. CODE HERE       ( -- adr )
  175.                 MOV BX, UP      PUSH DP [BX]
  176.                 NEXT
  177.                 END-CODE
  178.  
  179. CODE PAD        ( -- adr )
  180.                 MOV BX, UP
  181.                 MOV AX, DP [BX]
  182.                 ADD AX, # 80
  183.                 1PUSH           END-CODE
  184.  
  185. CODE -TRAILING  ( addr len -- addr1 len1 )
  186.                 POP BX
  187.                 OR BX, BX               \ LEAVE IF BX=0
  188.              0= IF      PUSH BX
  189.                         NEXT
  190.                 THEN
  191.                 POP DI
  192.                 MOV AL, # 32
  193.                 BEGIN
  194.                         CMP -1 [DI+BX], AL
  195.                      0= IF      2SWAP           \ compile time correction
  196.                                 DEC BX
  197.              0= UNTIL
  198.                         THEN
  199.                 PUSH DI
  200.                 PUSH BX
  201.                 NEXT            END-CODE
  202.  
  203. CODE COMP       ( addr1 addr2 len -- -1 | 0 | 1 )
  204.                 MOV DX, SI      POP CX
  205.                 POP DI          POP SI
  206.   CX<>0 IF
  207.                 PUSH ES         MOV ES, SSEG
  208.                 REPZ            CMPSB
  209.         0<> IF
  210. LABEL COMPX  0< IF
  211.                    MOV CX, # -1
  212.                 ELSE
  213.                    MOV CX, # 1
  214.                 THEN
  215.             THEN
  216.         THEN
  217. LABEL NOMORE    MOV SI, DX
  218.                 POP ES
  219.                 PUSH CX
  220.                 NEXT            END-CODE
  221.  
  222. CODE CAPS-COMP  ( addr1 addr2 len -- -1 | 0 | 1 )
  223.                 MOV DX, SI      POP CX
  224.                 POP DI          POP SI
  225.                 PUSH ES         MOV ES, SSEG
  226.             BEGIN
  227.                 JCXZ NOMORE
  228.                 MOV     AH, 0 [SI]      INC SI
  229.                 MOV ES: AL, 0 [DI]      INC DI
  230.                 OR AX, # $02020         CMP AH, AL
  231.                 JNE COMPX               DEC CX
  232.             AGAIN
  233.                 END-CODE
  234.  
  235. : COMPARE       ( addr1 addr2 len -- -1 | 0 | 1 )
  236.                 CAPS @ IF   CAPS-COMP   ELSE   COMP   THEN   ;
  237.  
  238. VARIABLE OSF
  239.  
  240. LABEL FCDOS     PUSH SI         PUSH BP
  241.                 INC CS: OSF WORD
  242.                 INT $21
  243.                 DEC CS: OSF WORD
  244.                 POP BP          POP SI
  245.                 RET             END-CODE
  246.  
  247. CODE XFDOS      ( DX CX BX AX ES DS-CX BX AX CY)
  248.                 POP DI          POP DS          POP AX
  249.                 POP BX          POP CX          POP DX
  250.                 PUSH ES         PUSH DS         POP ES
  251.                 PUSH CS
  252.                 MOV DS, DI      CALL FCDOS
  253.                 POP DS          POP ES          MOV DX, # -1
  254.             U>= IF
  255.                 XOR DX, DX
  256.             THEN
  257.                 PUSH CX         PUSH BX
  258.                 PUSH AX         PUSH DX
  259.                 NEXT            END-CODE
  260.  
  261. CODE ?CS:       ( -- CS )
  262.                 PUSH CS         NEXT            END-CODE
  263.  
  264. CODE ?ES:       ( -- CS )
  265.                 PUSH ES         NEXT            END-CODE
  266.  
  267. CODE @L         ( seg addr --- word )
  268.                 POP BX          POP DS          MOV AX, 0 [BX]
  269.                 MOV BX, CS      MOV DS, BX
  270.                 1PUSH           END-CODE
  271.  
  272. CODE C@L        ( seg addr --- byte )
  273.                 POP BX          POP DS          MOV AL, 0 [BX]
  274.                 XOR AH, AH      MOV BX, CS      MOV DS, BX
  275.                 1PUSH           END-CODE
  276.  
  277. CODE C!L        ( byt seg adr )
  278.                 POP BX          POP DS          POP AX
  279.                 MOV 0 [BX], AL  MOV BX, CS      MOV DS, BX
  280.                 NEXT            END-CODE
  281.  
  282. CODE !L         ( n seg adr -- )
  283.                 POP BX          POP DS          POP AX
  284.                 MOV 0 [BX], AX  MOV BX, CS      MOV DS, BX
  285.                 NEXT            END-CODE
  286.  
  287. CODE <BDOS>     ( n fun -- m )
  288.                 POP AX          MOV AH, AL      POP DX
  289.                 INT $21         SUB AH, AH
  290.                 1PUSH           END-CODE
  291.  
  292. DEFER BDOS      ' <BDOS> IS BDOS
  293.  
  294. CODE BDOS2      ( CX DX AX -- CX DX AX )
  295.                 POP AX          POP DX          POP CX
  296.                 MOV AH, AL      INT $21
  297.                 PUSH CX         PUSH DX         PUSH AX
  298.                 NEXT            END-CODE
  299.  
  300. : OS2           BDOS2 255 AND ;
  301.  
  302. VARIABLE BIOSCHAR       \ Holds the char from BIOS on scan by BIOSKEY?
  303. VARIABLE BIOSKEYVAL     \ Holds the key value from BIOSKEY
  304.  
  305. CODE BIOSKEY?   ( --- f1 )
  306.         BEGIN
  307.                 MOV AH, # 1
  308.                 INT $16
  309.                 MOV BIOSCHAR AX
  310.           0= IF
  311.                 MOV AX, # 0
  312.                 1PUSH
  313.              THEN
  314.                 CMP AX, # 0     \ Ignore Control Break keys
  315.      0= WHILE
  316.                 MOV AH, # 0     \ That is throw them away
  317.                 INT $16
  318.         REPEAT
  319.                 MOV AX, # -1
  320.                 1PUSH           END-CODE
  321.  
  322. CODE BIOSKEY    ( --- c1 )
  323.         BEGIN
  324.                 MOV AH, # 0
  325.                 INT $16
  326.                 CMP AX, # 0             \ Ignore Control BREAK, 00 Hex.
  327.     0<> UNTIL
  328.                 MOV BIOSKEYVAL AX
  329.                 1PUSH           END-CODE
  330.  
  331. DEFER KEYFILTER ' NOOP IS KEYFILTER     \ Pre-filter keys before passing on.
  332.  
  333. DEFER BGSTUFF   ' NOOP IS BGSTUFF       \ BACKGROUND STUFF
  334.  
  335. : (KEY?)        ( -- f )
  336.                 BGSTUFF BIOSKEY? ;
  337.  
  338. : (KEY)         ( -- CHAR )
  339.                 BEGIN   PAUSE KEY? UNTIL
  340.                 BIOSKEY DUP 127 AND 0=
  341.                 IF      FLIP 127 AND 128 OR
  342.                 ELSE    255 AND
  343.                 THEN    KEYFILTER ;
  344.  
  345. DEFER OUTPAUSE  ( ' PAUSE ) ' NOOP IS OUTPAUSE
  346. DEFER CONSOLE
  347.  
  348. CODE CMOVEL     ( sseg sptr dseg dptr cnt )
  349.                 CLD             MOV BX, SI
  350.                 POP CX          POP DI
  351.                 POP AX          POP SI
  352.                 POP DS          PUSH ES         MOV ES, AX
  353.                 OR CX, CX
  354.             0<> IF
  355.                 REPNZ           MOVSB
  356.             THEN
  357.                 POP ES
  358.                 MOV AX, CS      MOV DS, AX
  359.                 MOV SI, BX
  360.                 NEXT            END-CODE
  361.  
  362. CODE CMOVEL>    ( sseg sptr dseg dptr cnt )
  363.                 STD             MOV BX, SI
  364.                 POP CX          POP DI
  365.                 POP AX          POP SI
  366.                 POP DS          PUSH ES         MOV ES, AX
  367.                 OR CX, CX
  368.             0<> IF
  369.                 DEC CX          ADD DI, CX
  370.                 ADD SI, CX      INC CX
  371.                 REPNZ           MOVSB
  372.             THEN
  373.                 POP ES
  374.                 MOV AX, CS      MOV DS, AX
  375.                 MOV SI, BX
  376.                 CLD
  377.                 NEXT            END-CODE
  378.  
  379. $01000 VALUE #CODESEGS \ Number of segments needed for CODE.  64k
  380. $01800 VALUE #LISTSEGS \ Number of segments needed for : definitions. 64k
  381. $01000 VALUE #HEADSEGS \ Number of segments needed for HEADS. 64K
  382.  
  383. : MEMCHK        ( F1 --- )
  384.                 IF      ." Insufficient Memory"
  385.                         0 0 BDOS
  386.                 THEN ;
  387.  
  388. CODE DEALLOC    ( N1 -- F1 ) \ N1 = BLOCK TO DE-ALLOCATE, F1 = 0 IS OK
  389.                 MOV AH, # $49 \ F1 = 9 INVALID BLOCK ADDRESS
  390.                 POP DX
  391.                 PUSH ES         MOV ES, DX      INT $21
  392.              u< if
  393.                 sub ah, ah
  394.              else
  395.                 mov ax, # 0
  396.              then
  397.                 POP ES          1PUSH           END-CODE
  398.  
  399. CODE ALLOC      ( N1 -- N2 N3 F1 )      \ N1 = SIZE NEEDED, N3 = SEGMENT
  400.                                         \ N2 = LARGEST SEGMENT AVAILABLE
  401.                 MOV AH, # $48            \ F1 = 8 NOT ENOUGH MEMORY.
  402.                 POP BX
  403.                 INT $21
  404.                 PUSH BX         PUSH AX
  405.              u< if
  406.                 sub ah, ah
  407.              else
  408.                 mov ax, # 0
  409.              then
  410.                 1PUSH           END-CODE
  411.  
  412. : MEMSET        ( N1 --- F1 )
  413.                 0 0 ROT $04A00 ?CS: DUP XFDOS >R 3DROP R> ;
  414.  
  415. : DOSVER        0 $030 BDOS $0FF AND ;
  416.  
  417. DEFER CURSORSET ' NOOP IS CURSORSET
  418.  
  419. : SETYSEG       ( --- )   \ SETS HEAD SEGMENT + MORE SPACE
  420.                 [ LABEL 'SETYSEG ]
  421.                 ?CS: SSEG !
  422.                 ?CS: TYPESEG !
  423.                 XSEGLEN @ XSEG @ + XDPSEG !
  424.                 XDP OFF
  425.                 DPSTART @ DP !
  426.                 DOSVER 2 <
  427.                 IF      ." Must have DOS 2.x or higher."
  428.                         0 0 BDOS
  429.                 THEN
  430.                 #CODESEGS #LISTSEGS + #HEADSEGS + MEMSET MEMCHK
  431.                 #OUT 0! $018 ( 24 DECIMAL ) #LINE !
  432.                 CURSORSET ;
  433.  
  434. CODE YHERE      ( -- adr )
  435.                 PUSH YDP        NEXT
  436.                 END-CODE
  437.  
  438. CODE YS:        ( W -- YSEG W )
  439.                 POP AX          PUSH YSEG
  440.                 1PUSH           END-CODE
  441.  
  442. CODE Y@         ( addr -- n )
  443.                 POP BX
  444.                 MOV DS, YSEG
  445.                 PUSH 0 [BX]
  446.                 MOV BX, CS      MOV DS, BX
  447.                 NEXT            END-CODE
  448.  
  449. CODE Y!         ( n addr -- )
  450.                 POP BX
  451.                 MOV DS, YSEG
  452.                 POP 0 [BX]
  453.                 MOV BX, CS      MOV DS, BX
  454.                 NEXT            END-CODE
  455.  
  456. CODE YC@        ( addr -- char )
  457.                 POP BX          SUB AX, AX
  458.                 MOV DS, YSEG
  459.                 MOV AL, 0 [BX]
  460.                 MOV BX, CS      MOV DS, BX
  461.                 1PUSH           END-CODE
  462.  
  463. CODE YC!        ( char addr -- )
  464.                 POP BX          POP AX
  465.                 MOV DS, YSEG
  466.                 MOV 0 [BX], AL
  467.                 MOV BX, CS      MOV DS, BX
  468.                 NEXT            END-CODE
  469.  
  470. CODE Y,         ( N --- )
  471.                 MOV BX, YDP
  472.                 ADD YDP # 2 WORD
  473.                 POP CX
  474.                 MOV DS, YSEG
  475.                 MOV 0 [BX], CX
  476.                 MOV BX, CS      MOV DS, BX
  477.                 NEXT
  478.                 END-CODE
  479.  
  480. CODE YCSET      ( byte addr -- )
  481.                 POP BX          POP AX
  482.                 MOV DS, YSEG
  483.                 OR 0 [BX], AL
  484.                 MOV BX, CS      MOV DS, BX
  485.                 NEXT            END-CODE
  486.  
  487. CODE YHASH      ( ystr vocaddr -- thread )
  488.                 POP DX          POP BX
  489.                 MOV DS, YSEG
  490.                 MOV AX, 1 [BX]          \ Get first and second chars
  491.                 SHL AL, # 1             \ Shift first char left one
  492.                 MOV CL, 0 [BX]          \ Get count
  493.                 AND CX, # 31            \ mask out all but actual word length
  494.                 DEC CX                  \ dec, and if zero then use a blank.
  495.     CX<>0  IF   ADD AL, AH
  496.            ELSE MOV AH, # 32
  497.                 ADD AL, AH              \ Plus second char
  498.            THEN SHL AX, # 1             \ The sum shifted left one again
  499.                 ADD AL, 0 [BX]          \ Plus count byte
  500.                 AND AX, # #THREADS 1-
  501.                 SHL AX, # 1     ADD AX, DX
  502.                 MOV CX, CS      MOV DS, CX
  503.                 1PUSH           END-CODE
  504.  
  505. CODE XHERE      ( -- seg adr )
  506.                 PUSH XDPSEG     PUSH XDP
  507.                 NEXT            END-CODE
  508.  
  509. CODE X,         ( n -- )        \ XHERE !L  2 XDP +!
  510.                 POP AX
  511.                 MOV BX, XDP
  512.                 MOV DS, XDPSEG
  513.                 MOV 0 [BX], AX
  514.                 MOV BX, CS
  515.                 MOV DS, BX
  516.                 ADD XDP # 2 WORD
  517.                 NEXT            END-CODE
  518.  
  519. CODE XC,        ( n -- )        \ XHERE C!L 1 XDP +!
  520.                 POP AX
  521.                 MOV BX, XDP
  522.                 MOV DS, XDPSEG
  523.                 MOV 0 [BX], AL
  524.                 MOV BX, CS
  525.                 MOV DS, BX
  526.                 INC XDP WORD
  527.                 NEXT            END-CODE
  528.  
  529. CODE PR-STATUS  ( N1 --- F1 )
  530.                 POP DX          \ PRINTER NUMBER
  531.                 MOV AH, # 2
  532.                 PUSH SI         PUSH BP
  533.                 INT $17         POP BP
  534.                 POP SI          MOV AL, AH
  535.                 MOV AH, # 0
  536.                 1PUSH           END-CODE
  537.  
  538.                 \ $090 is printer not busy & printer selected.
  539. : <?PTR.READY> ( --- F1 )     0 PR-STATUS ( $090 AND ) $090 = ;
  540.  
  541. DEFER ?PRINTER.READY    ' <?PTR.READY> IS ?PRINTER.READY
  542.  
  543. DEFER CR
  544. DEFER PEMIT     \ ' (PRINT) IS PEMIT
  545.  
  546. : (EMIT)        ( char -- )
  547.                 PRINTING @ IF DUP PEMIT #OUT DECR THEN CONSOLE ;
  548.  
  549. : CRLF          ( -- )
  550.                 13 EMIT 10 EMIT #OUT OFF
  551.                 #LINE DUP @ 1+
  552.                 PRINTING @ 0=
  553.                 IF      24 MIN  THEN SWAP ! ;
  554.  
  555. : FEMIT         ( C1 --- ) SP@ 1 TYPE DROP ;
  556.  
  557. : SPACE         ( -- )    BL EMIT ;
  558.  
  559. CREATE SPCS     ( --- A1 )      \ An array of 80 spaces for use by SPACES
  560.                 $02020
  561.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  562.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  563.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  564.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  565.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP ,     ,
  566.  
  567. : SPACES        ( N --- )
  568.                 SPCS SWAP 80 MIN 0 MAX TYPE ;
  569.  
  570. : BACKSPACES    ( n -- )  0 ?DO   BS EMIT -2 #OUT +! LOOP  ;
  571.  
  572. : BEEP          ( -- )    BELL (EMIT) #OUT DECR ;
  573.  
  574. : BS-IN         ( n c -- 0 | n-1 )
  575.                 >R DUP
  576.                 IF      1-   BS
  577.                 ELSE    BELL
  578.                 THEN    EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ;
  579.  
  580. : (DEL-IN)      ( n c -- 0 | n-1 )
  581.                 >R DUP
  582.                 IF      1-  #OUT @ BS EMIT SPACE #OUT ! BS
  583.                 ELSE    BELL
  584.                 THEN    EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ;
  585.  
  586. DEFER DEL-IN    ' (DEL-IN) IS DEL-IN
  587.  
  588. : BACK-UP       ( n c -- 0 c )
  589.                 >R DUP BACKSPACES   DUP SPACES   BACKSPACES   0  R> ;
  590.  
  591. : RESET-IN      ( c -- ) FORTH   TRUE ABORT" Reset"  ;
  592.  
  593. DEFER RES-IN    ' RESET-IN IS RES-IN
  594.  
  595. : P-IN          ( c -- c ) PRINTING @ 0= PRINTING !  ;
  596.  
  597. : (ESC-IN)      ( C -- ) >R 2DUP + @ EMIT 1+ R> ;
  598.  
  599. DEFER ESC-IN    ' (ESC-IN) IS ESC-IN
  600.  
  601. : CR-IN         ( m a n c -- m a m C )
  602.                 >R SPAN !   OVER   BL EMIT R>  ;
  603.  
  604. : (CHAR)        ( a n char -- a n+1 CHAR )
  605.                 dup>r 3DUP EMIT + C!   1+  R> ;
  606.  
  607. DEFER CHAR      ' (CHAR) IS CHAR
  608. DEFER ^CHAR     ' CHAR   IS ^CHAR
  609.  
  610. : NORM-KEYTABLE
  611.                EXEC:
  612.    ^CHAR   ^CHAR  ^CHAR  RES-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR
  613.    DEL-IN  ^CHAR  ^CHAR  ^CHAR  ^CHAR  CR-IN   ^CHAR  ^CHAR
  614.    P-IN    ^CHAR  ^CHAR  ^CHAR  ^CHAR  BACK-UP ^CHAR  ^CHAR
  615.    BACK-UP ^CHAR  ^CHAR  ESC-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR ;
  616.  
  617. DEFER KEYTABLE  ' NORM-KEYTABLE IS KEYTABLE
  618.  
  619.                 \ expect to a buffer that may already contain some data.
  620. : NEXPECT       ( ADR LEN START -- )
  621.                 dup>r IF OVER R@ TYPE THEN
  622.                 DUP SPAN !   SWAP R> ( LEN ADR 0_SOFAR )
  623.                 BEGIN   2 PICK OVER - ( len adr #so-far #left )
  624.                 WHILE   KEY DUP BL <
  625.                         IF      DUP KEYTABLE DROP
  626.                         ELSE    DUP 127 =
  627.                                 IF   DEL-IN   ELSE   CHAR   THEN  DROP
  628.                         THEN
  629.                 REPEAT  3DROP ;
  630.  
  631. : (EXPECT)      ( adr len -- )
  632.                 0   NEXPECT  ;          ( len adr 0 )
  633.  
  634. DEFER EXPECT    ' (EXPECT) IS EXPECT
  635.  
  636. CODE TIB        ( --- addr )
  637.                 PUSH 'TIB       NEXT    END-CODE
  638.  
  639. : QUERY         ( -- )          TIB 80 EXPECT  SPAN @ #TIB ! >IN OFF  ;
  640.  
  641.       VARIABLE DISK-ERROR
  642.    -2 CONSTANT LIMIT
  643.  
  644. LIMIT 10 - CONSTANT FIRST
  645. FIRST 10 - CONSTANT INIT-R0
  646.  
  647. DECIMAL
  648.  
  649. FORTH DEFINITIONS
  650.  
  651. : HEX           ( -- )   16 BASE !  ;
  652. : DECIMAL       ( -- )   10 BASE !  ;
  653. : OCTAL         ( -- )    8 BASE !  ;
  654.  
  655. DEFER DEFAULT
  656.  
  657. LABEL FAIL      SUB AX, AX      1PUSH           END-CODE
  658.  
  659. CODE DIGIT      ( char base -- n f )
  660.                 POP DX          POP AX          PUSH AX
  661.                 SUB AL, # ASCII 0
  662.                 JB FAIL         CMP AL, # 9
  663.               > IF
  664.                 CMP AL, # 17    JB FAIL         SUB AL, # 7
  665.               THEN
  666.                 CMP AL, DL
  667.                 JAE FAIL
  668.                 MOV DL, AL      POP AX          MOV AX, # TRUE
  669.                 2PUSH           END-CODE
  670.  
  671. : DOUBLE?       ( -- f ) DPL @ 1+   0<> ;
  672.  
  673. : CONVERT       ( +d1 adr1 -- +d2 adr2 )
  674.                 BEGIN   1+  dup>r  C@  BASE @  DIGIT
  675.                 WHILE   SWAP  BASE @ UM*  DROP  ROT  BASE @ UM*  D+
  676.                         DOUBLE?  IF  DPL INCR THEN  R>
  677.                 REPEAT  DROP  R>  ;
  678.  
  679. : (NUMBER?)     ( adr -- d flag )
  680.                 0 0  ROT  DUP 1+  C@  ASCII -  =  DUP  >R  -  DPL -1!
  681.                 BEGIN   CONVERT  DUP C@  ASCII , ASCII / BETWEEN
  682.                 WHILE   DPL 0!
  683.                 REPEAT  -ROT  R> IF  DNEGATE  THEN   ROT C@ BL =  ;
  684.  
  685. : NUMBER?       ( adr -- d flag )
  686.                 FALSE  OVER COUNT BOUNDS
  687.                 ?DO     I C@ BASE @ DIGIT NIP
  688.                         IF      DROP TRUE LEAVE THEN
  689.                 LOOP
  690.                 IF  (NUMBER?)  ELSE  DROP  0 0 FALSE  THEN  ;
  691.  
  692. comment:
  693.  
  694.   A simple word to make Forth accept numbers prefixed with $ as Hex
  695. numbers.
  696.  
  697. comment;
  698.  
  699. CODE +1=$?      ( A1 --- A1 F1 )        \ is second char in a1 a $ ?
  700.                 POP BX
  701.                 PUSH BX
  702.                 MOV AL, 1 [BX]
  703.                 CMP AL, # ASCII $
  704.             0<> IF
  705.                         SUB AX, AX
  706.                 THEN
  707.                 1PUSH
  708.                 END-CODE
  709.  
  710. CODE +1='?      ( A1 --- A1 F1 )        \ is second char in a1 a $ ?
  711.                 POP BX
  712.                 PUSH BX
  713.                 MOV AL, 1 [BX]
  714.                 CMP AL, # ASCII '
  715.             0<> IF
  716.                         SUB AX, AX
  717.                 THEN
  718.                 1PUSH
  719.                 END-CODE
  720.  
  721. : (NUMBER)      ( A1 --- D1 )           \ Prefix with $ for auto HEX base.
  722.                 +1=$?                     \ $ is for HEX
  723.                 IF      dup>r DUP COUNT 1- 0 MAX >R
  724.                         DUP 1+ SWAP R> CMOVE    \ Extract the $.
  725.                         DUP C@ 1- OVER C!       \ Shorten count by 1.
  726.                         BL OVER COUNT + C!      \ Append a blank to string.
  727.                         BASE @ >R       \ Save the base for later restoral.
  728.                         HEX NUMBER?     \ Try to convert the number in HEX
  729.                         R> BASE !       \ Restore the BASE.
  730.                         DUP 0=          \ If its not a number, restore the $.
  731.                         IF      R@ COUNT >R DUP 1+ R> CMOVE>
  732.                                 R@ C@ 1+ R@ C!
  733.                                 ASCII $ R@ 1+ C!
  734.                         THEN    r>drop
  735.                 ELSE    +1='?                   \ recognize ' for ascii
  736.                         IF      2+ C@ 0 TRUE
  737.                                 DPL ON
  738.                         ELSE    NUMBER?
  739.                         THEN
  740.                 THEN
  741.                 NOT ?MISSING ;
  742.  
  743. DEFER NUMBER    ' (NUMBER) IS NUMBER
  744.  
  745. : HOLD          ( char -- )
  746.                 HLD DECR HLD @ C!   ;
  747.  
  748. : <#            ( -- )  PAD  HLD  !  ;
  749.  
  750. : #>            ( d# -- addr len )
  751.                 2DROP  HLD  @  PAD  OVER  -  ;
  752.  
  753. : SIGN          ( n1 -- )
  754.                 0< IF  ASCII -  HOLD  THEN  ;
  755.  
  756. : #             ( -- )
  757.                 BASE @ MU/MOD ROT 9 OVER <
  758.                 IF  7 + THEN ASCII 0  +  HOLD  ;
  759.  
  760. : #S            ( -- )
  761.                 BEGIN  #  2DUP  OR  0=  UNTIL  ;
  762.  
  763. : (U.)          ( u -- a l )    0    <# #S #>   ;
  764. : U.            ( u -- )        (U.)   TYPE SPACE   ;
  765. : U.R           ( u l -- )      >R   (U.)   R> OVER - SPACES   TYPE   ;
  766.  
  767. : (.)           ( n -- a l )    DUP ABS 0   <# #S   ROT SIGN   #>   ;
  768. : .             ( n -- )        (.)   TYPE SPACE   ;
  769. : .R            ( n l -- )      >R   (.)   R> OVER - SPACES   TYPE   ;
  770.  
  771. : (UD.)         ( ud -- a l )   <# #S #>   ;
  772. : UD.           ( ud -- )       (UD.)   TYPE SPACE   ;
  773. : UD.R          ( ud l -- )     >R   (UD.)   R> OVER - SPACES   TYPE  ;
  774.  
  775. : (D.)          ( d -- a l )    TUCK DABS   <# #S   ROT SIGN  #>   ;
  776. : D.            ( d -- )        (D.)   TYPE SPACE   ;
  777. : D.R           ( d l -- )      >R   (D.)   R> OVER - SPACES   TYPE   ;
  778.  
  779. LABEL DONE
  780.                 PUSH CX         NEXT            END-CODE
  781.  
  782. CODE  SKIP      ( addr len char -- addr' len' )
  783.                 POP AX          POP CX
  784.                 JCXZ DONE
  785.                 POP DI          PUSH ES         MOV ES, SSEG
  786.                 REPZ            SCASB           POP ES
  787.             0<> IF
  788.                 INC CX          DEC DI
  789.             THEN
  790.                 PUSH DI         PUSH CX
  791.                 NEXT            END-CODE
  792.  
  793. CODE  SCAN      ( addr len char -- addr' len' )
  794.                 POP AX          POP CX
  795.                 JCXZ DONE
  796.                 POP DI          PUSH ES
  797.                 MOV ES, SSEG    MOV BX, CX
  798.                 REPNZ           SCASB           POP ES
  799.              0= IF
  800.                 INC CX          DEC DI
  801.              THEN
  802.                 PUSH DI         PUSH CX
  803.                 NEXT            END-CODE
  804.  
  805. CODE /STRING    ( addr len n -- addr' len' )
  806.                 POP AX          POP BX
  807.                 PUSH BX         CMP BX, AX
  808.             U<= IF
  809.                 XCHG BX, AX     \ AX = SMALLER OF AX BX
  810.              THEN
  811.                 POP BX          POP DX
  812.                 ADD DX, AX      PUSH DX
  813.                 SUB BX, AX      PUSH BX
  814.                 NEXT            END-CODE
  815.  
  816. CODE SOURCE-PARSE-WRD  ( C1 --- A2 N2 )
  817.                 MOV DX, 'TIB
  818.                 MOV CX, #TIB
  819.                 POP BX
  820.                 PUSH ES                         \ Save ES for later restoral
  821.                 PUSH CX         MOV AX, >IN
  822.                 CMP CX, AX
  823.             U<= IF              MOV AX, CX      \ AX = SMALLER OF AX CX
  824.                 THEN
  825.                 ADD DX, AX
  826.                 SUB CX, AX
  827.                 MOV AX, BX
  828.                 MOV DI, DX
  829.           CX<>0 IF              MOV DX, DS      MOV ES, DX
  830.                                 REPZ            SCASB
  831.                             0<> IF              INC CX
  832.                                                 DEC DI
  833.                                 THEN
  834.                 THEN
  835.                 MOV DX, DI
  836.                 MOV AX, BX
  837.           CX<>0 IF              REPNZ           SCASB
  838.                              0= IF              INC CX
  839.                                                 DEC DI
  840.                                 THEN
  841.                 THEN
  842.                 SUB DI, DX      POP BX
  843.                 POP ES                          \ Restore ES
  844.                 PUSH DX         PUSH DI
  845.           CX<>0 IF      DEC CX
  846.                 THEN
  847.                 SUB BX, CX      MOV >IN BX
  848.                 NEXT            END-CODE
  849.  
  850. CODE SOURCE     ( -- addr len )         \ TIB #TIB @
  851.                 MOV DX, 'TIB
  852.                 MOV AX, #TIB
  853.                 2PUSH
  854.                 END-CODE
  855.  
  856. : PARSE         ( char -- addr len )
  857.                 >R   SOURCE >IN @ /STRING   OVER SWAP R> SCAN
  858.                 >R OVER -  DUP R>  0<> -  >IN +!  ;
  859.  
  860. DEFER 'WORD     ( -- adr )     ' HERE IS 'WORD
  861.  
  862. CODE PLACE-SUFIX.BL     ( from cnt to -- to )
  863.                 POP DX          MOV DI, DX
  864.                 POP CX          MOV 0 [DI], CL
  865.                 INC DI          CLD
  866.                 MOV BX, IP      MOV AX, DS
  867.                 POP IP
  868.                 PUSH ES         MOV ES, AX
  869.                 REPNZ           MOVSB
  870.                 MOV AL, # 32    STOSB
  871.                 MOV IP, BX      POP ES          PUSH DX
  872.                 NEXT            END-CODE
  873.  
  874. : WORD          ( char -- addr )
  875.                 SOURCE-PARSE-WRD 'WORD PLACE-SUFIX.BL ;
  876.  
  877.